{-# LANGUAGE GADTs #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveFunctor #-}

module Main where

import Control.Monad.Free

-- 指令集（每个指令都携带 continuation）
data ContractF a where
  Pay :: Double -> (() -> a) -> ContractF a
  WaitDays :: Int -> (() -> a) -> ContractF a
  IfMarketGoesUp :: (Bool -> a) -> ContractF a
  Log :: String -> (() -> a) -> ContractF a

deriving instance Functor ContractF


-- Free Monad 类型
type Contract = Free ContractF

-- 构造 DSL 的函数
pay :: Double -> Contract ()
pay amt = liftF (Pay amt id)

waitDays :: Int -> Contract ()
waitDays n = liftF (WaitDays n id)

ifMarketGoesUp :: Contract Bool
ifMarketGoesUp = liftF (IfMarketGoesUp id)

logMsg :: String -> Contract ()
logMsg msg = liftF (Log msg id)

-- 示例合约
contractExample :: Contract ()
contractExample = do
  logMsg "合约开始执行"
  waitDays 30
  up <- ifMarketGoesUp
  logMsg $ "市场状态: " ++ show up
  if up
    then do
      logMsg "执行上涨支付"
      pay 100
    else do
      logMsg "执行下跌支付"
      pay 0
  logMsg "合约执行完成"

-- 市场数据类型
type MarketData = [Bool]

-- 合约解释器
runContract :: MarketData -> Contract a -> IO a
runContract _ (Pure a) = return a
runContract md (Free instr) = case instr of
  Pay amt next -> do
    putStrLn $ "支付 $" ++ show amt
    runContract md (next ())
  WaitDays n next -> do
    putStrLn $ "等待 " ++ show n ++ " 天..."
    runContract (drop n md) (next ())
  IfMarketGoesUp next -> case md of
    [] -> do
      putStrLn "没有更多市场数据，假定为 False"
      runContract [] (next False)
    (x:xs) -> runContract xs (next x)
  Log msg next -> do
    putStrLn $ "[日志] " ++ msg
    runContract md (next ())

-- 主函数
main :: IO ()
main = do
  let market = replicate 30 False ++ [True]
  putStrLn "开始执行合约示例"
  runContract market contractExample
  putStrLn "合约执行完毕"
